COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00005 00003	1. Write  a  unary LISP  function,  LIST-OF-ATOMS, that  will  compute the  list  of
C00010 00004	(de loa (x)(loa1 x nil))
C00016 ENDMK
C⊗;

(DE APPEND (X Y)		;builds up structure from the outside
     (COND ((NULL X) Y)
	   (T (CONS (CAR X) 
       		    (APPEND (CDR X) Y)))))

(DE LENGTH (L)			;adds 1 from the outside
      (COND ((NULL L) 0)
	    (T (ADD1 (LENGTH (CDR L))))))

or:

(DE LENGTH (L)(LEN1 L 0))	; this pair  adds up from the inside
(DE LEN1 (L N)			; essentially "iterative"
    (COND ((NULL L) N)
	  (T (LEN1 (CDR L) (ADD1 N)))))

(DE SUBST (X Y Z)		; similar to  APPEND in structure
	(COND ((ATOM Z) (COND ((EQ  Y Z) X) 
			      (T Z)))
	      (T (CONS (SUBST X Y (CAR Z))
		       (SUBST X Y (CDR Z))))))


(DE FIB(N) (COND ((EQ N 0) 1)
		 ((EQ N 1) 1)
		 (T (PLUS (FIB (DIF N 2))
			  (FIB (DIF N 1))))))

(DE MEMBER (X L)(COND ((NULL L) NIL)	; note, T and NIL are representing true
		      ((EQUAL (CAR L) X) T) ; and false.
		      (T (MEMBER X (CDR L)))))

(DE PLUS (X Y)
	(COND ((EQ X 0) Y)
	      (T (PLUS (SUB1 X) 
		       (ADD1 Y)))))

where:
(DE SUB1 (X) (COND ((EQ X 0) error)
		   (T (PRED X 0))))

(DE PRED (X Y)				; a bit tricky --just find the predecessor
	(COND ((EQ (ADD1 Y) X) X)
	      (T (PRED X (ADD1 Y)))))


(DE TIMES (X Y)
   (COND ((EQ X 0) 0)
	 (T (TIMES (SUB1 X)
		   (PLUS  X Y)))))
		     

(DE REVERSE (X) (REV1 X ())	;this pair builds up  reversal in second arg.
(DE REV1 (X Y)
	(COND ((NULL X) Y)
	      (T (REV1 (CDR X)
		       (CONS (CAR X) Y)))))

or
(DE REVERSE (X)(APPEND (REVERSE (CDR X))	; this pair is a loss
		       (LIST (CAR X))))		; since much structure is built
						; and discarded

1. Write  a  unary LISP  function,  LIST-OF-ATOMS, that  will  compute the  list  of
(unique) atoms in an arbitrary S-expression.

2. Write  a unary  LISP function,  DEPTH, that  will compute  the maximum  depth  of
nesting of a list (list elements may be s-exprs).

3.Do problem 11.1 in AIP.

4. Write a read macro  that will take ?<symbol> into  (VAR <symbol>).  Write a  read
macro pair that will allow us to abbreviate (LIST exp1 ... expn) as <exp1 ... expn>

5. In MacLISP derivatives we find variations of a DO-construct:

	(DO ((v1 init1 incr1) ... (vn initn incrn))
	    (exit-expr  exit-value)
	     body-exp1 ... body-expn)

where the  vi's  are  to  be  local variables,  initialized  in  parallel  to  initi
(respectively) and on  each pass  through the DO-loop  incri is  evaluated (also  in
parallel) to be the new value of vi. Before beginning a pass through the    DO-body,
exit-expr is evaluated;  if the  resultant value  is non-NIL,  the DO-expression  is
exited with value, exit-value.  If exit-value is NIL  the sequence of body-exp's  is
evaluated in order; we then proceed to update the vi's to the incri values. Example:

(DE LENGTH (L)(DO ((X L (CDR X))(N 0 (ADD1 N)))
		  ((NULL X) N) ))  ;NO BODY IS NEEDED.

write a run-time macro that will convert a DO into a prog-collection.


	      II -----------A Simple data-base-------------

We want to investigate a data-base of  family trees. In particular, we want to  look
at the  "mother-hood"  relation (apple-pie-ness  comes  next week);  we  assume  all
individuals  in   our  base   are  female.    To  represent   the  relationship   "α
is-the-mother-of β", we will place  the name α on the  property-list of β under  the
property M-O (MOTHER OF).

(PUTPROP 'FELINA 'GILDA 'M-O) makes GILDA the mother of FELINA.

6.  Write a  function ADD whose  argument represents a  motherhood relationship  and
whose effect is to install that relationship in the data base.

eg (ADD '(GILDA M-O FELINA)) and (ADD '(GILDA M-O ISIS)) the ADD-function should  be
faithful to mother-ness (single mothers please ...hum).

7.Write a function called RETRIEVE whose  argument represents a MO-triple and  whose
value is T or NIL depending on whether the MO-relationship is in the base.

(RETRIEVE '(GILDA M-O FELINA)) should return NIL  before the above ADD is done,  and
should return T afterwards.

8. Write a binary predicate GRANDMOTHER, that will tell if the first argument is the
grandmother of the second.

9. Write  a binary  predicate,  SISTER, that  will tell  if  the two  arguments  are
sisters.

***For problem 10 you may find it useful to extend the ADD function.

10. Extend RETRIEVE to allow  retrieval of M-O values  by allowing variables in  the
arguments, where variables are represented as in problem 4.

For example: (RETRIEVE '(?X M-O FELINA)) should return ((X GILDA)).
	     (RETRIEVE '(GILDA M-O ?X))  should return ((X FELINA)(X ISIS)).

(de loa (x)(loa1 x nil))

(de loa1 (x l)(cond ((atom x) (cond ((member x l) l)
				    (t (cons x l))))
	            (t (loa1 (car x) (loa1 (cdr x) l)))]

--------------------------------------------
(de depth (l)(cond ((null l) 0)
		   (t (add1 (max (depth1 (car l))
				 (depth (cdr l)))))))

(de depth1(x)(cond ((atom x) 0)
		   (t (add1 (max (depth1 (car x))
				 (depth1 (cdr x))]

--------------------------------------------
(de descri (item node)
  (loop	(initial foo nil)
	(until (setq foo (is-terminal node)))
	(while (not(null node)))
	(next node (next-mode ((test:node node)item) node))

	(result (cond (foo (result:terminal node))
		      (t nil))))


--------------------------------------------
(drm /? () (list 'var (read]

(drm /> () 'e-o-l)

(drm /< () (cons 'list  (find-r-b)))

(de find-r-b () 
         (loop	(initial l nil)
		(until (eq 'e-o-l (setq r (read))))
		(next l (nconc l(list r)))
		(result l)))


--------------------------------------------
	(DO ((v1 init1 incr1) ... (vn initn incrn))
	    (exit-expr  exit-value)
	     body-exp1 ... body-expn)


	(PROG (v1 ...vn)

	        (PUSH ST initi)
		 ...    

	        (SETQ vn-i (POP ST))
		 ...     

	  LOOP	(PUSH ST incri)
		  ...   

	        (SETQ vn-i (POP ST))
		  ...     

		(COND ((exit-expr (RETURN exit-value)))
		body-exp1  ... body-expn
		(GO LOOP)]

(dm do (l) (do-b (cadr l)(caddr l)(cdddr l))

(de do-b (init exit body)
	(let (vars (var-part init)
	      rvars (reverse vars)
	      inis (ini-part init)
	      incs (inc-part init))

	|"(PROG @vars 
		|@(pusher inis)
		|@(poper rvars)
	   LOOP |@(pusher incs)
		|@(poper rvars)
		(COND (@(test exit) (RETURN @(value exit))))
		|@body
		(GO LOOP))))



(de pusher (l)
     (cond ((null l) nil)
	   (t (cons (list 'PUSH 'ST (car l))
		    (pusher (cdr l))))))

(de poper (l) 
     (cond ((null l) nil)
	   (t (cons (list 'SETQ (car l) '(POP ST))
		    (poper (cdr l))))))

--------------------------------------------

(de add (obj) (let (lhs (car obj) 
		    rel (cadr obj)
		    rhs (caddr l))
		(cond ((get rhs rel) 'error)
		      (t (putprop rhs lhs rel)))))

--------------------------------------------
(de retrieve (obj)
  (let (lhs (car obj) 
	rel (cadr obj)
    	rhs (caddr l)
	val (get rhs rel))
   (cond (val (eq val lhs))
	 (t nil))))

--------------------------------------------
(de grandmother (x y)
  (let (mo-y (get y 'MO))
     (eq (get mo-y 'MO) x)))

--------------------------------------------
(de sister (x y)
 (eq (get x 'MO) (get y 'MO))










--------------------------------------------
augment ADD function to install  nmaes in global name-list called fam-tree.

(de retrieve (obj)
  (let (lhs (car obj) 
	rel (cadr obj)
    	rhs (caddr l))
   (cond ((is-var lhs) (list (var-part lhs) (get rhs rel)))
	 ((is-var rhs) (search fam-tree rel lhs (var-part rhs) nil))
	 (t (old-ret obj)))))

(de search (tr rel val var match)
  (cond ((null tr) match)
	((eq (get (car tr) rel) val) (search (cdr tr) 
					     rel 
					     val 
					     var 
					     (append (list var (get (car tr) rel))
						     tr)))
	(t (search (cdr tr) rel val var match]